home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Software Vault: The Gold Collection
/
Software Vault - The Gold Collection (American Databankers) (1993).ISO
/
cdr35
/
pcbvpurg.zip
/
PCBVPURG.BAS
< prev
next >
Wrap
BASIC Source File
|
1993-06-10
|
5KB
|
168 lines
'+--------------------------[ PCBVPURG Ver 1.00 ]----------------------------+
'| Written By Gary Meeker 06/10/93 Updated / / |
'| SYSOP: SHARP Technical Support Line BBS Lawrenceville, GA |
'| (404) 962-1788 300-14400 Baud. 24 Hours |
'+---------------------------------------------------------------------------+
'V1.00 06/10/93 - Initial Release
'
DEFINT A-Z
' QuickPack Declarations
DECLARE FUNCTION TrapInt% (Value%, LoLimit%, HiLimit%)
DECLARE SUB KillFile (FileName$)
DECLARE SUB NameFile (OldName$, NewName$)
' PDQ Declarations
DECLARE FUNCTION PDQExist% (FileSpec$)
DECLARE FUNCTION PDQParse$ (Work$)
DECLARE SUB SetDelimitChar (Char)
' ProBas Declarations
' Myown Declarations
DECLARE FUNCTION EndString(Temp$, EndCh$)
DECLARE FUNCTION FindLastCh(St$, BYVAL Ch)
DECLARE SUB DEC ALIAS "_dec" (IntVar%)
DECLARE SUB DecStep(IntVar%, StepVar%)
DECLARE SUB INC ALIAS "_inc" (IntVar%)
DECLARE SUB IncStep(IntVar%, StepVar%)
' Local Declarations
DECLARE FUNCTION EndChar$(St$, EndCh$)
DECLARE FUNCTION MakeExt$(St$, Ext$)
DECLARE FUNCTION FindIndex%(IndexFiles$, IndexLetter$)
' $INCLUDE: 'PCBTYPES.INC'
'TYPE PCBNDXRECORD
' Index AS INTEGER
' UserName As STRING * 25
'END TYPE
DIM SHARED Phone$(1 TO 256), User$(1 TO 256), Dat$(1 TO 256), UserNo(1 TO 256)
DIM UserName AS STRING * 25
Q$ = CHR$(34)
Q2$ = Q$ + "," + Q$
PRINT "PCBVPurg Ver 1.00 - Copyright 1993 Gary Meeker"
SetDelimitChar 32
CM$ = UCASE$(COMMAND$)
PCBVFile$ = PDQParse$(CM$)
OutputFile$ = MakeExt$(PCBVFile$, "$$$")
OldFile$ = MakeExt$(PCBVFile$, "BAK")
USERSIndexPath$ = EndChar$(PDQParse$(CM$), "\")
IF NOT PDQExist(PCBVFile$) THEN
PRINT PCBVFile$; " not found!"
GOTO ErrorExit
ELSEIF NOT PDQExist(USERSIndexPath$ + "PCBNDX.A") THEN
PRINT "Invalid Index file path"
GOTO ErrorExit
END IF
PRINT "Purging "; PCBVFile$
OPEN PCBVFile$ FOR INPUT ACCESS READ SHARED AS #1
OPEN OutputFile$ FOR OUTPUT ACCESS WRITE SHARED AS #2
DO WHILE NOT EOF(1)
PRINT "-";
Count = 0
DO WHILE Count < 256 AND NOT EOF(1)
INC Count
INPUT #1, Phone$(Count), User$(Count), Dat$(Count)
LOOP
PRINT "|";
Count2 = 0
DO WHILE Count > 0
INC Count2
LSET UserName$ = User$(Count2)
UserNo(Count2) = FindIndex%(USERSIndexPath$ + "PCBNDX.", UserName$)
DEC Count
LOOP
PRINT "/";
Count = 0
DO WHILE Count2 > 0
INC Count
IF UserNo(Count) > 0 THEN
PRINT #2, Q$; Phone$(Count); Q2$; User$(Count); Q2$; Dat$(Count); Q$
END IF
DEC Count2
LOOP
LOOP
CLOSE #2
CLOSE #1
PRINT
KillFile OldFile$
NameFile PCBVFile$, OldFile$
NameFile OutputFile$, PCBVFile$
PRINT "Done"
ErrorExit:
END
FUNCTION EndChar$(St$, EndCh$) STATIC
Temp$ = RTRIM$(ST$)
IF (LEN(Temp$) = 0) OR EndString(Temp$, EndCh$) THEN
EndChar$ = Temp$
ELSE
EndChar$ = Temp$ + EndCh$
END IF
END FUNCTION
FUNCTION MakeExt$(St$, Ext$) STATIC
ExtPos = FindLastCh(St$, 46)
IF ExtPos THEN
MakeExt$ = LEFT$(St$, ExtPos) + Ext$
ELSE
MakeExt$ = RTRIM$(St$) + "." + Ext$
END IF
END FUNCTION
FUNCTION FindIndex%(IndexFiles$, UserName$) STATIC
DIM PCBNDX AS PCBNDXRECORD
IndexLen = LEN(PCBNDX)
IndexFile$ = IndexFiles$ + CHR$(TrapInt(ASC(LEFT$(UserName$, 1)), 65, 90))
IndexFileNo = FREEFILE
FindIndex = -1
IF PDQExist(IndexFile$) THEN
OPEN IndexFile$ FOR RANDOM AS #IndexFileNo LEN = Indexlen
Indexes = LOF(IndexFileNo) \ IndexLen
Test = 0
IF Indexes < 1 THEN
ELSE
Jump = Indexes \ 2 + (Indexes MOD 2): Match = Jump
DO
Test = Test - (Jump = 1)
Jump = Jump \ 2 + (Jump MOD 2)
Match = TrapInt(Match, 1, Indexes)
GET #IndexFileNo, Match, PCBNDX
IF UserName$ = PCBNDX.UserName$ THEN
FindIndex = PCBNDX.Index
EXIT DO
ELSEIF UserName$ < PCBNDX.UserName$ THEN
DecStep Match, Jump
ELSE
IncStep Match, Jump
END IF
IF Test > 1 THEN
EXIT DO
END IF
LOOP
END IF
CLOSE #IndexFileNo
END IF
END FUNCTION
'This file was last compiled with:
'BC PCBVPURG.BAS /o /s;
'LINK PCBVPURG+
' C:\QB\LIB\_NOERROR C:\QB\LIB\_NOFIELD C:\QB\LIB\_NOREAD C:\QB\LIB\_NOVAL+
' /ex /nod /noe /packcode /far
'
' nul
' C:\QB\LIB\SCREEN C:\QB\LIB\MYOWN C:\QB\LIB\QPPRO C:\QB\LIB\PDQFP
'